home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / utils / lib-complete.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  12.2 KB  |  331 lines

  1. ;; ========================================================================
  2. ;; lib-complete.el --  Completion on a search path
  3. ;; Author          : Mike Williams <mike-w@cs.aukuni.ac.nz>
  4. ;; Created On      : Sat Apr 20 17:47:21 1991
  5. ;; Last Modified By: Heiko M|nkel <muenkel@tnt.uni-hannover.de>
  6. ;; Last Modified On: Thu Jul 1 14:23:00 1994
  7. ;; RCS Info        : $Revision: 1.7.1 $ $Locker:  $
  8. ;; ========================================================================
  9. ;; NOTE: this file must be recompiled if changed.
  10. ;;
  11. ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
  12. ;;
  13. ;; Keywords: utility, lisp
  14.  
  15. ;; This file is part of XEmacs.
  16.  
  17. ;; XEmacs is free software; you can redistribute it and/or modify it
  18. ;; under the terms of the GNU General Public License as published by
  19. ;; the Free Software Foundation; either version 2, or (at your option)
  20. ;; any later version.
  21.  
  22. ;; XEmacs is distributed in the hope that it will be useful, but
  23. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  24. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  25. ;; General Public License for more details.
  26.  
  27. ;; You should have received a copy of the GNU General Public License
  28. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  29. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  30.  
  31. ;;; Synched up with: Not part of FSF.
  32.  
  33. ;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his
  34. ;; helpful suggestions.
  35.  
  36. ;; The function locate-file is removed, because of its incompatibility
  37. ;; with the buildin function of the lemacs 19.10 (Heiko M|nkel).
  38.  
  39. ;; There is now the new function find-library in this package.
  40.  
  41. (provide 'lib-complete)
  42.  
  43. ;;=== Usage ===============================================================
  44. ;; 
  45. ;; (autoload (fmakunbound 'load-library) "lib-complete" nil t)
  46. ;; (autoload 'library-all-completions "lib-complete")
  47. ;; (autoload 'read-library "lib-complete")
  48. ;; (autoload 'find-library "lib-complete"
  49. ;;  "Find and edit the source for the library named LIBRARY.
  50. ;; The extension of the LIBRARY must be omitted.")
  51.  
  52. ;;=== Locate a file in a search path ======================================
  53.  
  54. ;(defun locate-file (FILE SEARCH-PATH &optional SUFFIX-LIST PRED)
  55. ;  "Search for FILE on SEARCH-PATH (list).  If optional SUFFIX-LIST is
  56. ;provided, allow file to be followed by one of the suffixes.
  57. ;Optional second argument PRED restricts the number of files which
  58. ;may match.  The default is file-exists-p."
  59. ;  (if (not SUFFIX-LIST) (setq SUFFIX-LIST '("")))
  60. ;  (if (not PRED) (setq PRED 'file-exists-p))
  61. ;  (if (file-name-absolute-p FILE) (setq SEARCH-PATH '(nil)))
  62. ;  (if (equal FILE "") (error "Empty filename"))
  63. ;  (let ((filelist 
  64. ;     (mapcar 
  65. ;      (function (lambda (ext) (concat FILE ext)))
  66. ;      SUFFIX-LIST)))
  67. ;    ;; Search SEARCH-PATH for a readable file in filelist
  68. ;    (catch 'found
  69. ;      (while SEARCH-PATH
  70. ;    (let ((filelist filelist))
  71. ;      (while filelist
  72. ;        (let ((filepath (expand-file-name (car filelist) 
  73. ;                          (car SEARCH-PATH))))
  74. ;          (if (funcall PRED filepath)
  75. ;          (throw 'found filepath)))
  76. ;        (setq filelist (cdr filelist))))
  77. ;    (setq SEARCH-PATH (cdr SEARCH-PATH))))
  78. ;    ))
  79.  
  80. ;;=== Determine completions for filename in search path ===================
  81.  
  82. (defun library-all-completions (FILE SEARCH-PATH &optional FULL FAST)
  83.   "Return all completions for FILE in any directory on SEARCH-PATH.
  84. If optional third argument FULL is non-nil, returned pathnames should be 
  85.   absolute rather than relative to some directory on the SEARCH-PATH.
  86. If optional fourth argument FAST is non-nil, don't sort the completions,
  87.   or remove duplicates."
  88.   (setq FILE (or FILE ""))
  89.   (if (file-name-absolute-p FILE)
  90.       ;; It's an absolute file name, so don't need SEARCH-PATH
  91.       (progn
  92.     (setq FILE (expand-file-name FILE))
  93.     (file-name-all-completions 
  94.      (file-name-nondirectory FILE) (file-name-directory FILE)))
  95.     (let ((subdir (file-name-directory FILE))
  96.       (file (file-name-nondirectory FILE))
  97.       all-completions)
  98.       ;; Make list of completions in each directory on SEARCH-PATH
  99.       (while SEARCH-PATH
  100.     (let* ((dir (concat (file-name-as-directory 
  101.                  (expand-file-name (car SEARCH-PATH)))
  102.                 subdir))
  103.            (dir-prefix (if FULL dir subdir)))
  104.       (if (file-directory-p dir)
  105.           (let ((subdir-completions 
  106.              (file-name-all-completions file dir)))
  107.         (while subdir-completions
  108.           (setq all-completions 
  109.             (cons (concat dir-prefix (car subdir-completions))
  110.                   all-completions))
  111.           (setq subdir-completions (cdr subdir-completions))))))
  112.     (setq SEARCH-PATH (cdr SEARCH-PATH)))   
  113.       (if FAST all-completions
  114.     (let ((sorted (nreverse (sort all-completions 'string<)))
  115.           compressed)
  116.       (while sorted
  117.         (if (equal (car sorted) (car compressed)) nil
  118.           (setq compressed (cons (car sorted) compressed)))
  119.         (setq sorted (cdr sorted)))
  120.       compressed)))))
  121.  
  122. ;;=== Utilities ===========================================================
  123.  
  124. (defmacro progn-with-message (MESSAGE &rest FORMS)
  125.   "(progn-with-message MESSAGE FORMS ...)
  126. Display MESSAGE and evaluate FORMS, returning value of the last one."
  127.   ;; based on Hallvard Furuseth's funcall-with-message
  128.   (` 
  129.    (if (eq (selected-window) (minibuffer-window))
  130.        (save-excursion
  131.      (goto-char (point-max))
  132.      (let ((orig-pmax (point-max)))
  133.        (unwind-protect
  134.            (progn
  135.          (insert " " (, MESSAGE)) (goto-char orig-pmax)
  136.          (sit-for 0)        ; Redisplay
  137.          (,@ FORMS))
  138.          (delete-region orig-pmax (point-max)))))
  139.      (prog2
  140.       (message "%s" (, MESSAGE))
  141.       (progn (,@ FORMS))
  142.       (message "")))))
  143.  
  144. (put 'progn-with-message 'lisp-indent-hook 1)
  145.  
  146. ;;=== Completion caching ==================================================
  147.  
  148. (defconst lib-complete:cache nil
  149.   "Used within read-library and read-library-internal to prevent 
  150. costly repeated calls to library-all-completions.
  151. Format is a list of lists of the form
  152.  
  153.     ([<path> <subdir>] <cache-record> <cache-record> ...)
  154.  
  155. where each <cache-record> has the form
  156.  
  157.    (<root> <modtimes> <completion-table>)")
  158.  
  159. (defun lib-complete:better-root (ROOT1 ROOT2)
  160.   "Return non-nil if ROOT1 is a superset of ROOT2."
  161.   (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
  162.        (string-match
  163.     (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
  164.     ROOT2)))
  165.  
  166. (defun lib-complete:get-completion-table (FILE PATH FILTER)
  167.   (let* ((subdir (file-name-directory FILE))
  168.      (root (file-name-nondirectory FILE))
  169.      (PATH 
  170.       (mapcar 
  171.        (function (lambda (dir) (file-name-as-directory
  172.                     (expand-file-name (or dir "")))))
  173.        PATH))
  174.      (key (vector PATH subdir FILTER))
  175.      (real-dirs 
  176.       (if subdir
  177.           (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
  178.         PATH))
  179.      (path-modtimes
  180.       (mapcar 
  181.        (function (lambda (fn) (if fn (nth 5 (file-attributes fn))))) 
  182.        real-dirs))
  183.      (cache-entry (assoc key lib-complete:cache))
  184.      (cache-records (cdr cache-entry)))
  185.     ;; Look for cached entry
  186.     (catch 'table
  187.       (while cache-records
  188.     (if (and 
  189.          (lib-complete:better-root (nth 0 (car cache-records)) root)
  190.          (equal (nth 1 (car cache-records)) path-modtimes))
  191.         (throw 'table (nth 2 (car cache-records))))
  192.     (setq cache-records (cdr cache-records)))
  193.       ;; Otherwise build completions
  194.       (let ((completion-list 
  195.          (progn-with-message "(building completion table...)"
  196.            (library-all-completions FILE PATH nil 'fast)))
  197.         (completion-table (make-vector 127 0)))
  198.     (while completion-list
  199.       (let ((completion
  200.          (if (or (not FILTER) 
  201.              (file-directory-p (car completion-list))) 
  202.              (car completion-list)
  203.            (funcall FILTER (car completion-list)))))
  204.         (if completion
  205.         (intern completion completion-table)))
  206.       (setq completion-list (cdr completion-list)))
  207.     ;; Cache the completions
  208.     (lib-complete:cache-completions key root 
  209.                     path-modtimes completion-table)
  210.     completion-table))))
  211.  
  212. (defvar lib-complete:max-cache-size 20 
  213.   "*Maximum number of search paths which are cached.")
  214.  
  215. (defun lib-complete:cache-completions (KEY ROOT MODTIMES TABLE)
  216.   (let ((cache-entry (assoc key lib-complete:cache))
  217.     (cache-records (cdr cache-entry))
  218.     (new-cache-records (list (list ROOT MODTIMES TABLE))))
  219.     (if (not cache-entry) nil
  220.       ;; Remove old cache entry
  221.       (setq lib-complete:cache (delq cache-entry lib-complete:cache))
  222.       ;; Copy non-redundant entries from old cache entry
  223.       (while cache-records
  224.     (if (or (equal ROOT (nth 0 (car cache-records)))
  225.         (lib-complete:better-root ROOT (nth 0 (car cache-records))))
  226.         nil
  227.       (setq new-cache-records 
  228.         (cons (car cache-records) new-cache-records)))
  229.     (setq cache-records (cdr cache-records))))
  230.     ;; Add entry to front of cache
  231.     (setq lib-complete:cache
  232.       (cons (cons KEY (nreverse new-cache-records)) lib-complete:cache))
  233.     ;; Trim cache
  234.     (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
  235.       (if tail (setcdr tail nil)))))
  236.  
  237. ;;=== Read a filename, with completion in a search path ===================
  238.  
  239. (defun read-library-internal (FILE FILTER FLAG)
  240.   "Don't call this."
  241.   ;; Relies on read-library-internal-search-path being let-bound
  242.   (let ((completion-table
  243.      (lib-complete:get-completion-table
  244.       FILE read-library-internal-search-path FILTER)))
  245.     (cond
  246.      ((not completion-table) nil)
  247.      ;; Completion table is filtered before use, so the PREDICATE
  248.      ;; argument is redundant.
  249.      ((eq FLAG nil) (try-completion FILE completion-table nil))
  250.      ((eq FLAG t) (all-completions FILE completion-table nil))
  251.      ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
  252.      )))
  253.  
  254. (defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH 
  255.                 FULL FILTER)
  256.   "Read library name, prompting with PROMPT and completing in directories
  257. from SEARCH-PATH.  A nil in the search path represents the current
  258. directory.  Completions for a given search-path are cached, with the
  259. cache being invalidated whenever one of the directories on the path changes.
  260. Default to DEFAULT if user enters a null string.
  261. Optional fourth arg MUST-MATCH non-nil means require existing file's name.
  262.   Non-nil and non-t means also require confirmation after completion.
  263. Optional fifth argument FULL non-nil causes a full pathname, rather than a 
  264.   relative pathname, to be returned.  Note that FULL implies MUST-MATCH.
  265. Optional sixth argument FILTER can be used to provide a function to
  266.   filter the completions.  This function is passed the filename, and should
  267.   return a transformed filename (possibly a null transformation) or nil, 
  268.   indicating that the filename should not be included in the completions."
  269.   (let* ((read-library-internal-search-path SEARCH-PATH)
  270.      (library (completing-read PROMPT 'read-library-internal 
  271.                    FILTER (or MUST-MATCH FULL) nil)))
  272.     (cond 
  273.      ((equal library "") DEFAULT)
  274.      (FULL (locate-file library read-library-internal-search-path ".el:.elc"))
  275.      (t library))))
  276.  
  277. ;; NOTE: as a special case, read-library may be used to read a filename
  278. ;; relative to the current directory, returning a *relative* pathname
  279. ;; (read-file-name returns a full pathname).
  280. ;;
  281. ;; eg. (read-library "Local header: " '(nil) nil)
  282.  
  283. (defun get-library-path ()
  284.   "Front end to read-library"
  285.   (read-library "Find Library file: " load-path nil t t
  286.           (function (lambda (fn) 
  287.                   (cond 
  288.                    ((string-match "\\.el$" fn)
  289.                 (substring fn 0 (match-beginning 0))))))
  290.           ))
  291.  
  292. ;;=== Replacement for load-library with completion ========================
  293.  
  294. (defun load-library (LIBRARY)
  295.   "Load the library named LIBRARY."
  296.   (interactive 
  297.    (list (read-library "Load Library: " load-path nil nil nil
  298.           (function (lambda (fn) 
  299.                   (cond 
  300.                    ((string-match "\\.elc?$" fn)
  301.                 (substring fn 0 (match-beginning 0))))))
  302.           ))) 
  303.   (load LIBRARY))
  304.  
  305. ;;=== find-library with completion (Author: Heiko Muenkel) ===================
  306.  
  307. (defun find-library (library)
  308.   "Find and edit the source for the library named LIBRARY.
  309. The extension of the LIBRARY must be omitted."
  310.   (interactive 
  311.    (list 
  312.     (get-library-path)))
  313.   (find-file library))
  314.  
  315. (defun find-library-other-window (library)
  316.   "Load the library named LIBRARY."
  317.   (interactive 
  318.    (list (get-library-path)))
  319.   (find-file-other-window library))
  320.  
  321. (defun find-library-other-screen (library)
  322.   "Load the library named LIBRARY."
  323.   (interactive 
  324.    (list (get-library-path)))
  325.   (find-file-other-screen library))
  326.  
  327. (define-key global-map "\C-xl" 'find-library)
  328. (define-key global-map "\C-x4l" 'find-library-other-window)
  329. (define-key global-map "\C-x5l" 'find-library-other-screen)
  330.  
  331.